Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/caldr/caldr1.frm

Text File | 1995-05-08 | 14KB | 529 lines

VERSION 2.00
Begin Form Form1
   BackColor       =   &H00C0C0C0&
   Caption         =   "Calendar Demo"
   ClientHeight    =   4020
   ClientLeft      =   1080
   ClientTop       =   1485
   ClientWidth     =   7365
   Height          =   4425
   Left            =   1020
   LinkTopic       =   "Form1"
   ScaleHeight     =   268
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   491
   Top             =   1140
   Width           =   7485
   Begin CommandButton Command1
      Caption         =   "Calendar"
      Height          =   525
      Left            =   1140
      TabIndex        =   7
      Top             =   165
      Width           =   1665
   End
   Begin PictureBox Calendar
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H00800000&
      Height          =   1800
      Left            =   4590
      ScaleHeight     =   118
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   147
      TabIndex        =   0
      Top             =   255
      Visible         =   0   'False
      Width           =   2235
      Begin SSCommand btnMonth
         BevelWidth      =   0
         Caption         =   "Command3D1"
         Font3D          =   0  'None
         Height          =   285
         Index           =   0
         Left            =   615
         TabIndex        =   5
         Top             =   570
         Width           =   315
      End
      Begin SSCommand btnYear
         BevelWidth      =   0
         Caption         =   "Command3D1"
         Font3D          =   0  'None
         Height          =   300
         Index           =   0
         Left            =   1005
         TabIndex        =   2
         Top             =   405
         Width           =   315
      End
      Begin PictureBox Picture1
         AutoRedraw      =   -1  'True
         BackColor       =   &H00C0C0C0&
         Height          =   375
         Left            =   120
         ScaleHeight     =   23
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   24
         TabIndex        =   1
         Top             =   645
         Width           =   390
         Begin PictureBox Picture2
            BackColor       =   &H00000000&
            BorderStyle     =   0  'None
            ForeColor       =   &H00C0C0C0&
            Height          =   165
            Left            =   90
            ScaleHeight     =   11
            ScaleMode       =   3  'Pixel
            ScaleWidth      =   14
            TabIndex        =   6
            Top             =   75
            Width           =   210
         End
      End
      Begin Label lblMonth
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Label1"
         Height          =   165
         Left            =   180
         TabIndex        =   4
         Top             =   330
         Width           =   630
      End
      Begin Label lblYear
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Label1"
         Height          =   210
         Left            =   225
         TabIndex        =   3
         Top             =   120
         Width           =   870
      End
   End
   Begin Label Label1
      BackColor       =   &H00C0C0C0&
      Caption         =   "Click button to display calendar.  Clicking on a date highlights and sets it. A set date can be removed by double clicking on it.  Feel free to improve upon.  Any suggestions to speed display when you advance or retard the calendar with the arrows would be appreciated. This just shows what's possible with VB, alone.  Much was suggested by  VB Knowledge Base article,  ""How to Make a Spreadsheet-style Grid that Allows Editing"". I do contract programming in VB and Access and would appreciate any leads for work you can pass my way.                                        Glenn Silverman :  CompuServe 71450,2750"
      Height          =   2820
      Left            =   225
      TabIndex        =   8
      Top             =   825
      Width           =   3945
   End
End
'Max grid size
Const grid_col_max = 10
Const grid_row_max = 20

'grid dimensions
Dim w As Single
Dim h As Single

'Current grid size
Dim grid_cols As Integer
Dim grid_rows As Integer

'Current cell position
Dim grid_col As Integer
Dim grid_row As Integer

'Grid string contents
Dim grid_text(35) As String

'Grid cell numbers
Dim cell(35) As Rect

'Grid line positions
Dim grid_line_col(grid_col_max) As Integer
Dim grid_line_row(grid_row_max) As Integer

'Calendar date setting
Dim calDate As Long

Sub AdvanceMonth ()
    Dim c, m, y, ds
    c = DateValue(lblMonth + " 1, " + lblYear)
    m = Month(c) + 1
    If m = 13 Then
        m = 1
        y = Year(c) + 1
    Else
        y = Year(c)
    End If
    ds = DateSerial(y, m, 1)
    ShowMonth ds
End Sub

Sub AdvanceYear ()
    Dim c, m, y, ds
    c = DateValue(lblMonth + " 1, " + lblYear)
    y = Year(c) + 1
    m = Month(c)
    ds = DateSerial(y, m, 1)
    ShowMonth ds
End Sub

Sub btnMonth_Click (Index As Integer)
    If Index = 0 Then
        RetardMonth
    Else
        AdvanceMonth
    End If
End Sub

Sub btnYear_Click (Index As Integer)
    If Index = 1 Then
        AdvanceYear
    Else
        RetardYear
    End If
End Sub

Sub BuildCal ()
    Dim i, l, t
    ReDim DaysOfWeek(7) As String
    Dim x1 As Integer
    Dim x2 As Integer
    Dim y1 As Integer
    Dim y2 As Integer


    DaysOfWeek(0) = "S"
    DaysOfWeek(1) = "M"
    DaysOfWeek(2) = "T"
    DaysOfWeek(3) = "W"
    DaysOfWeek(4) = "T"
    DaysOfWeek(5) = "F"
    DaysOfWeek(6) = "S"



    'Set control dimensions
    h = Calendar.Height / 8
    w = Calendar.Width / 7

    'Set headings
    SetControl lblYear, h, 5 * w + 1, " ", &HC0C0C0
    ControlText lblYear, True, &HC0, 2
    lblYear.Move w, 0

    SetControl lblMonth, h, 5 * w + 1, " ", &HC0C0C0
    ControlText lblMonth, True, &HC0, 2
    lblMonth.Move w, h

   'set weekday heads
   For i = 0 To 6
    x1 = i * w + 10
    y1 = 2 * h + 3
    x2 = (i + 1) * w - 1
    y2 = 3 * h - 1

    Calendar.CurrentX = x1 - 6 + (x2 - x1 - Picture1.TextWidth(DaysOfWeek(i))) / 2
    Calendar.CurrentY = y1 + (y2 - y1 - Picture1.TextHeight(DaysOfWeek(i))) / 2
    Calendar.Print DaysOfWeek(i)
   Next i

   'set grdCal
    Picture1.Move 0, 3 * h, 7 * w, 5 * h
    Picture2.Visible = False

   'build cal grid
    grid_build 7, 5


   'Set buttons
    btnYear(0).Move 0, 0, w, h
    btnYear(0).Caption = "<"
    Load btnYear(1)
    btnYear(1).Visible = True
    btnYear(1).Move 6 * w, 0
    btnYear(1).Caption = ">"

    btnMonth(0).Move 0, h, w, h
    btnMonth(0).Caption = "<"
    Load btnMonth(1)
    btnMonth(1).Visible = True
    btnMonth(1).Move 6 * w, h
    btnMonth(1).Caption = ">"

End Sub

Sub Command1_Click ()
    Calendar.Visible = True
End Sub

Sub ControlText (c As Control, wt, tcol, al)
    c.FontBold = wt
    c.ForeColor = tcol
    c.Alignment = al
End Sub

Function date_set (col As Integer, row As Integer) As Long
    date_set = DateValue(lblMonth + " " + grid_text(row * 7 + col) + ", " + lblYear)
End Function

Sub DayCalc (first, days)
    Dim d, nday
    Dim i As Integer
    Dim c As Rect
    Dim x1 As Integer
    Dim x2 As Integer
    Dim y1 As Integer
    Dim y2 As Integer
    Dim txtColor As Long
    Dim col As Integer
    Dim row As Integer

    For i = 0 To 33 + first
       c = cell(i Mod 35)

       x1 = c.upper.x
       y1 = c.upper.y
       x2 = c.lower.x
       y2 = c.lower.y

       'clear cell
       Picture1.Line (x1 + 1, y1 + 1)-(x2 - 1, y2 - 1), Picture1.BackColor, BF

       d = i - first + 2
       If d < 1 Or d > days Then
          nday = " "
       Else
          nday = d
       End If

       'display day number in cell
        Picture1.CurrentX = x1 - 6 + (x2 - x1 - Picture1.TextWidth(nday)) / 2
        Pictur